home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-xp.adb < prev    next >
Text File  |  1994-05-19  |  5KB  |  126 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                            S Y S T E M . X P                             --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.3 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. package body System.Xp is
  26.  
  27.    --------------------------
  28.    -- Exponentiate_Integer --
  29.    --------------------------
  30.  
  31.    --  Note that negative exponents get a constraint error because the
  32.    --  subtype of the Right argument (the exponent) is Natural.
  33.  
  34.    function Exponentiate_Integer
  35.      (Left : Type_Of_Base; Right : Natural) return Type_Of_Base
  36.    is
  37.       Result : Type_Of_Base := 1;
  38.       Factor : Type_Of_Base := Left;
  39.       Exp    : Natural := Right;
  40.  
  41.    begin
  42.       --  We use the standard logarithmic approach, Exp gets shifted right
  43.       --  testing successive low order bits and Factor is the value of the
  44.       --  base raised to the next power of 2.
  45.  
  46.       --  Note: it is not worth special casing the cases of base values -1,0,+1
  47.       --  since the expander does this when the base is a literal, and other
  48.       --  cases will be extremely rare.
  49.  
  50.       while Exp /= 0 loop
  51.          if Exp rem 2 /= 0 then
  52.             Result := Result * Factor;
  53.          end if;
  54.  
  55.          Factor := Factor * Factor;
  56.          Exp := Exp / 2;
  57.       end loop;
  58.  
  59.       return Result;
  60.    end Exponentiate_Integer;
  61.  
  62.    ------------------------
  63.    -- Exponentiate_Float --
  64.    ------------------------
  65.  
  66.    function Exponentiate_Float
  67.      (Left : Type_Of_Base; Right : Integer) return Type_Of_Base
  68.    is
  69.       Result : Type_Of_Base := 1.0;
  70.       Factor : Type_Of_Base := Left;
  71.       Exp    : Natural := Right;
  72.  
  73.    begin
  74.       --  We use the standard logarithmic approach, Exp gets shifted right
  75.       --  testing successive low order bits and Factor is the value of the
  76.       --  base raised to the next power of 2. For positive exponents we
  77.       --  multiply the result by this factor, for negative exponents, we
  78.       --  divide by this factor.
  79.  
  80.       if Exp >= 0 then
  81.  
  82.          --  For a positive exponent, if we get a constraint error during
  83.          --  this loop, it is an overflow, and the constraint error will
  84.          --  simply be passed on to the caller.
  85.  
  86.          while Exp /= 0 loop
  87.             if Exp rem 2 /= 0 then
  88.                Result := Result * Factor;
  89.             end if;
  90.  
  91.             Factor := Factor * Factor;
  92.             Exp := Exp / 2;
  93.          end loop;
  94.  
  95.          return Result;
  96.  
  97.       else -- Exp < 0 then
  98.  
  99.          --  For the negative exponent case, a constraint error during this
  100.          --  calculation happens if Factor gets too large, and the proper
  101.          --  response is to return 0.0, since what we essenmtially have is
  102.          --  1.0 / infinity, and the closest model number will be zero.
  103.  
  104.          begin
  105.  
  106.             while Exp /= 0 loop
  107.                if Exp rem 2 /= 0 then
  108.                   Result := Result * Factor;
  109.                end if;
  110.  
  111.                Factor := Factor * Factor;
  112.                Exp := Exp / 2;
  113.             end loop;
  114.  
  115.             return 1.0 / Result;
  116.  
  117.          exception
  118.  
  119.             when Constraint_Error =>
  120.                return 0.0;
  121.          end;
  122.       end if;
  123.    end Exponentiate_Float;
  124.  
  125. end System.Xp;
  126.